home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / closure.t < prev    next >
Encoding:
Text File  |  1990-06-11  |  18.5 KB  |  458 lines
  1. (herald (back_end closure)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29.  
  30.  
  31. ;;; Closure analysis.
  32. ;;;=========================================================================
  33. (lset *top-level-lambda* nil)
  34.  
  35. (define (close-analyze-top node variables)
  36.     (set *unit-closures* nil)
  37.     (set *unit-templates* nil)
  38.     (let* ((l ((call-arg 1) (lambda-body node)))
  39.            (env (list (lambda-self-var node)))
  40.            (via (lambda-self-var l)))
  41.       (bind ((*top-level-lambda* via)) 
  42.         (close-analyze-body (lambda-body l) via env via))
  43.       (set *unit* (create-unit l)) 
  44.       (create-environment l *unit* (fx* CELL 4))
  45.       (return (cddr (closure-env *unit*)) *unit-templates* l))) ; skip the 
  46.                                                                 ; *environment*
  47.                                                                 ; and top-level
  48. (define (close-analyze-body node up henv hvia)
  49.   (cond ((and (primop-node? (call-proc node))
  50.               (eq? (primop-value (call-proc node)) primop/Y))
  51.          (really-close-analyze-body
  52.                        (cons ((call-arg 1) node) 
  53.                              (call-args (lambda-body ((call-arg 2) node))))
  54.                        up henv hvia))
  55.         (else
  56.          (really-close-analyze-body (call-proc+args node)
  57.                                     up henv hvia))))
  58.  
  59.  
  60. (define (really-close-analyze-body nodes up henv hvia)
  61.   (receive (live cics vframe)
  62.            (accumulate-environment nodes up henv hvia)
  63.     (if cics (close-analyze-heap cics live up henv hvia))))
  64.  
  65. (define (close-analyze-heap cics live up henv hvia)
  66.   (let* ((cic-vars (map lambda-self-var cics))
  67.          (live (set-difference live cic-vars))
  68.          (global? (or (memq? hvia live)
  69.                       (any? (lambda (node)
  70.                               (eq? (lambda-env node) 'unit-internal-closure))
  71.                             cics)))
  72.          (inter (intersection live henv))               
  73.          (link (if (or global? inter)
  74.                     hvia 
  75.                     nil))
  76.          (delta (set-difference (delq! hvia live) henv)))  
  77.     (xselect (lambda-strategy (variable-binder hvia))
  78.       ((strategy/heap)                            
  79.        (if (or global? (cdr inter))
  80.            (create-closure link cic-vars delta nil up)
  81.            (create-closure nil cic-vars live nil up))))
  82.     (walk (lambda (cic)
  83.             (cond ((object-lambda? cic)
  84.                    (destructure (((#f proc #f . methods) 
  85.                                   (call-args (lambda-body cic))))
  86.                      (walk (lambda (method)                     
  87.                               (set (lambda-env method) (lambda-env cic))
  88.                               (close-analyze-body (lambda-body method)
  89.                                                   up
  90.                                                   live
  91.                                                   (lambda-self-var cic)))
  92.                            (cons proc methods))))
  93.                   (else
  94.                    (close-analyze-body (lambda-body cic)
  95.                        up
  96.                                        live
  97.                                        (lambda-self-var cic)))))
  98.           cics)))
  99.  
  100.  
  101.  
  102. ;;; (proc+handler k object-proc method-names . methods)
  103. ;;; Must hack this by not returning the proc as a cic.  The parent lambda will
  104. ;;; masquerade as the proc until code generation
  105.  
  106. (define (accumulate-environment nodes up henv hvia)
  107.   (iterate loop ((nodes nodes) (live '()) (cics '()) (vframe '()) (stack '()))
  108.     (cond ((null? nodes)
  109.            (return live cics vframe))
  110.           ((not (lambda-node? (car nodes)))
  111.            (loop (cdr nodes) live cics vframe stack))
  112.           (else
  113.            (xselect (lambda-strategy (car nodes))
  114.              ((strategy/heap)
  115.               (cond ((object-lambda? (car nodes))
  116.                      (let* ((args (cdddr (call-args (lambda-body (car nodes)))))
  117.                             (new-cics (close-analyze-object (car nodes) args)))
  118.                        (loop (cdr nodes)
  119.                              (union (lambda-live (car nodes)) live)
  120.                              (append new-cics cics)
  121.                              vframe
  122.                              stack)))
  123.                     ((eq? (lambda-env (car nodes)) 'unit-internal-closure)
  124.                      (push *unit-closures* (car nodes))
  125.                      (let ((env (lambda-live (car nodes)))
  126.                            (via (lambda-self-var (car nodes))))
  127.                        (close-analyze-body (lambda-body (car nodes))
  128.                                            via env via)
  129.                        (loop (cdr nodes) (union env live) cics vframe stack)))
  130.                     (else
  131.                      (loop (cdr nodes)
  132.                            (union (lambda-live (car nodes)) live)
  133.                            (cons (car nodes) cics)
  134.                            vframe
  135.                            stack))))
  136.              ((strategy/open strategy/stack)
  137.               (close-analyze-body (lambda-body (car nodes)) up henv hvia)
  138.               (loop (cdr nodes) live cics vframe stack))
  139.              ((strategy/label)
  140.               (close-analyze-label (car nodes) henv hvia)
  141.               (loop (cdr nodes) live cics vframe stack)))))))                
  142.  
  143. (define (close-analyze-object obj methods)
  144.   (cond ((null? (lambda-live obj))
  145.          (let ((proc (cadr (call-args (lambda-body obj)))))
  146.            (push *unit-closures* obj)
  147.            (let ((env (lambda-live obj))
  148.                  (via (lambda-self-var obj)))
  149.              (close-analyze-body (lambda-body proc) via env via)
  150.              (walk (lambda (node)
  151.                      (let ((env (lambda-live node))
  152.                            (via (lambda-self-var (node-parent (node-parent node)))))
  153.                        (close-analyze-body (lambda-body node) via env via)))
  154.                     methods)))
  155.            '())
  156.         (else  
  157.          (list obj))))
  158.                                     
  159.  
  160.  
  161. (define (close-analyze-label node heapenv heapvia)
  162.   (let* ((live (lambda-live node))
  163.          (need-contour? (eq? (lambda-env node) 'needs-link))
  164.          (b (variable-binder heapvia))
  165.          (via (if (or (lambda-live b) (known-lambda? b)) 
  166.                   *top-level-lambda* 
  167.                   heapvia)))
  168.     (set (lambda-env node) (create-join-point live via need-contour? node))
  169.     (walk (lambda (var) (set (variable-definition var) 'many)) live)
  170.     (close-analyze-body (lambda-body node) via '() via)))
  171.  
  172.  
  173. (define (set-eq? s1 s2)
  174.   (if (fx= (length s1) (length s2))
  175.       (every? (lambda (x) (memq? x s2)) s1)
  176.       nil))      
  177.         
  178. ;;; Environment structure is the lambda-env slot of each lambda which is
  179. ;;; strategy/stack or strategy/heap. The variables are sorted by size.
  180. ;;; (For stack closures) a continuation is represented as offset -1 in the
  181. ;;;  a-list.
  182.  
  183. (lset *unit* nil)
  184. (lset *unit-closures* nil)
  185. (lset *unit-templates* nil)
  186. (lset *unit-literals* nil)                              
  187. (lset *unit-variables* nil)
  188.  
  189. (define-structure-type environment
  190.   closure    ; the closure this environment is a member of
  191.   cic-offset ; offset of this environment's descriptor in the closure
  192.   (((print self stream)
  193.      (format stream "#{Environment_~S in Closure_~S}"
  194.              (object-hash self)    
  195.              (object-hash (environment-closure self))))))
  196.  
  197. (define-structure-type closure             
  198.   members     ; list of closure-internal-closures (variables)
  199.   vframe-lambdas 
  200.   env         ; a-list of variables and offsets in the closure (in bytes)
  201.   pointer     ; number of pointer slots
  202.   scratch     ; number of scratch slots
  203.   size        ; total size of closure (in bytes)
  204.   cit-offset  ; offset of first
  205.   link        ; superior closure
  206.   (((print self stream)
  207.      (format stream "#{Closure_~S with ~D vars, cics ~S}"
  208.              (object-hash self)    
  209.              (length (closure-env self))
  210.              (map variable-unique-name
  211.                   (closure-members self))))))
  212.  
  213. (define-structure-type join-point
  214.   env                  ;;; free variables
  215.   arg-specs            ;;; list of numbers for argument-positions
  216.   global-registers     ;;; list of (register . variable)
  217.   contour              ;;; nearest superior template
  218.   contour-needed?
  219.   call-below?
  220.   *lambda*
  221.   )
  222.  
  223. (define (create-join-point env contour needed? lamb)
  224.   (let ((j (make-join-point)))
  225.     (set (join-point-env j) env)
  226.     (set (join-point-arg-specs j) nil)
  227.     (set (join-point-global-registers j) 'not-yet-determined)
  228.     (set (join-point-contour-needed? j) needed?)
  229.     (set (join-point-contour j) contour)
  230.     (set (join-point-call-below? j) 
  231.      (if (continuation? lamb)
  232. nil;         (fx= (call-below? (lambda-body lamb)) call-below/definitely)
  233.          (fx>= (call-below? (lambda-body lamb)) call-below/maybe)))
  234.     j))
  235.  
  236. (define (stack-below? node)
  237.   (if (eq? (node-role (node-parent (node-parent node))) call-proc)
  238.       '#f
  239.       (let ((body (lambda-body node)))
  240.         (select (call-exits body)
  241.           ((0) nil)
  242.           ((1) (let ((exit (car (call-args body))))
  243.                  (xcond ((lambda-node? (call-proc body))
  244.                          (stack-below? (call-proc body)))
  245.                         ((leaf-node? exit) nil)
  246.                         ((eq? (lambda-strategy exit) strategy/stack) t)
  247.                         ((eq? (lambda-strategy exit) strategy/open)
  248.                          (stack-below? exit)))))
  249.           ((2) (let ((exit1 ((call-arg 1) body))
  250.                      (exit2 ((call-arg 2) body)))
  251.                  (and (and (lambda-node? exit1) (stack-below? exit1))
  252.                      (and (lambda-node? exit2) (stack-below? exit2)))))))))
  253.                                               
  254. (define-structure-type loc-list        ;;; appears in the unit
  255.   var
  256.   )
  257.  
  258.  
  259. (define (create-loc-list var)
  260.   (let ((l (make-loc-list)))
  261.     (set (loc-list-var l) var)
  262.     l))
  263.  
  264.  
  265. (define (create-unit thing)
  266.  (let ((unit (make-closure))) 
  267.    (receive (a-list count) (do-unit-variables thing)   
  268.      (do ((lits *unit-literals* (cdr lits))
  269.           (count count (fx+ count CELL))
  270.           (a-list a-list `((,(car lits) . ,count) ,@a-list)))
  271.        ((null? lits)
  272.         (do ((closures (reverse! *unit-closures*) (cdr closures))
  273.              (count count (fx+ count CELL))
  274.              (a-list a-list `((,(car closures) . ,count) ,@a-list)))
  275.             ((null? closures)
  276.          (set (closure-pointer unit) (fx- (fx/ count CELL) 1))
  277.          (set (closure-scratch unit) 0)
  278.          (set (closure-env unit)  (reverse! a-list))
  279.          (set (closure-cit-offset unit) nil)
  280.          unit)
  281.           (create-environment (car closures) unit count)))))))
  282.  
  283. (define *the-environment* (create-variable '*the-environment*))
  284.                            
  285.                                    
  286. (define (do-unit-variables thing)
  287.   (iterate loop ((a-list `((,*the-environment* . ,(fx* CELL 3))
  288.                (,thing . ,(fx* CELL 4))))
  289.                  (vars (delq! *the-environment* *unit-variables*)); header 0
  290.                  (count (fx* CELL 5)))                            ; id 4
  291.     (cond ((null? vars) (return a-list count))                    ; filename 8
  292.           (else                                                   ; env 12
  293.            (let ((var (car vars)))                                ; thing 16
  294.          (receive (value? vcell?)
  295.               (cond ((defined-variable? var)
  296.                  (if (null? (cdr (variable-refs var)))
  297.                  (return nil t)
  298.                  (return (all-important-refs-are-calls? var) t)))
  299.                 ((all-important-refs-are-calls? var)
  300.                  (return t nil))
  301.                 (else
  302.                  (return nil t)))
  303.            (if (and value? vcell?)
  304.            (loop `(,(cons var (fx+ count cell)) 
  305.                ,(cons (create-loc-list var) count)
  306.                ,@a-list)
  307.              (cdr vars)
  308.              (fx+ count (fx* CELL 2)))
  309.            (if value? 
  310.                (loop `(,(cons var count) ,@a-list)
  311.                  (cdr vars)
  312.                  (fx+ count CELL))
  313.                (loop `(,(cons (create-loc-list var) count) ,@a-list)
  314.                  (cdr vars)
  315.                  (fx+ count CELL))))))))))
  316.  
  317.  
  318. (define (create-env-a-list pointer scratch)
  319.   (do ((vars `(,@pointer . ,(sort-list! scratch scratch-compare)) (cdr vars))
  320.        (count 0 (fx+ count CELL))
  321.        (a-list '() `((,(car vars) . ,count) . ,a-list)))
  322.       ((null? vars)
  323.        (reverse! a-list))))
  324.  
  325. (define *dummy-var* (create-variable '*dummy-var*))
  326. (set (variable-number *dummy-var*) 0)
  327.  
  328. (define (create-closure link cics vars vframe-lambdas up)
  329.   (let ((closure (make-closure)))
  330.     (walk cell-collapse vars)
  331.     (let* ((cit? (any? (lambda (cic)
  332.              (eq? (lambda-env (variable-binder cic))
  333.                   'unit-internal-template))
  334.                cics))
  335.        (pointer (if cit?
  336.                (cons up (sort-vars vars))
  337.                (sort-vars vars)))
  338.        (scratch '()))
  339.       (let* ((scratch-slots 0)
  340.              (pvars (if (null? (cdr cics))
  341.                         (if link (cons link pointer) pointer) 
  342.                         (case (length pointer)
  343.                             ((0)
  344.                              (if link 
  345.                                  (list link *dummy-var*)
  346.                                  (list *dummy-var* *dummy-var*))) 
  347.                             ((1)
  348.                              (if link
  349.                                  (list link (car pointer))
  350.                                  (list *dummy-var* (car pointer))))
  351.                             (else
  352.                              (if link (cons link pointer) pointer)))))
  353.              (pointer-slots (fx+ (length pvars) 
  354.                                  (if cics (length cics) 1)))
  355.              (var-a-list (create-env-a-list
  356.                            (if cics 
  357.                                `(,(car cics) ,@pvars ,@(cdr cics)) 
  358.                                `(,*dummy-var* ,@pvars))
  359.                            scratch)))            
  360.           (set (closure-link closure) link)
  361.           (set (closure-members closure) cics)   
  362.           (set (closure-vframe-lambdas closure) vframe-lambdas)
  363.           (set (closure-cit-offset closure) (if cit? up nil))
  364.           (set (closure-env        closure) var-a-list)
  365.           (set (closure-scratch    closure) scratch-slots)
  366.           (set (closure-pointer    closure) (fx- pointer-slots 1))
  367.           (set (closure-size       closure)
  368.                (fx* (fx+ scratch-slots pointer-slots) CELL))
  369.           (if (null? vframe-lambdas)
  370.               (create-environments var-a-list closure cics)
  371.               (create-vframe-environments closure vframe-lambdas))
  372.           closure))))
  373.  
  374. (define (cell-collapse var)
  375.   (set (variable-definition var) 'many))
  376.  
  377. #|                                                  
  378. (define (cell-collapse var)
  379.   (cond ((null? (variable-definition var))
  380.          (set (variable-definition var) 
  381.               (if (cell-collapsable? var) 'one 'many)))
  382.         ((eq? (variable-definition var) 'one)
  383.          (set (variable-definition var) 'many))))
  384.  
  385.  
  386. (define (cell-collapsable? var)
  387.   (every? (lambda (ref)
  388.             (or (and (eq? (node-role ref) (call-arg 3))
  389.                      (primop-ref? (call-proc (node-parent ref))
  390.                                   primop/contents-location))
  391.                 (and (eq? (node-role ref) (call-arg 4))
  392.                      (primop-ref? (call-proc (node-parent ref))
  393.                                   primop/set-location))))
  394.           (variable-refs var)))
  395. |#
  396.  
  397. (define (create-environments var-a-list closure cics)
  398.   (create-environment (variable-binder (car cics)) closure 0)
  399.   (orbit-debug "~a (~d) ~s env = ~a~%" (lambda-strategy (variable-binder (car cics)))
  400.           (object-hash (variable-binder (car cics)))
  401.           (variable-name (car cics))
  402.           (map (lambda (var) (variable-name (car var)))
  403.                (closure-env closure)))
  404.   (walk (lambda (cic)
  405.           (create-environment (variable-binder cic)
  406.                               closure
  407.                               (cdr (assq cic var-a-list))))
  408.         (cdr cics)))
  409.  
  410. (define (create-vframe-environments closure vframe-lambdas)
  411.   (walk (lambda (cic)
  412.           (set (lambda-env cic) nil))
  413.          vframe-lambdas)
  414.   (orbit-debug "~a (~d) ~s env = ~a~%" (lambda-strategy (car vframe-lambdas))
  415.           (object-hash (car vframe-lambdas))
  416.           (variable-name (lambda-self-var (car vframe-lambdas)))
  417.           (map (lambda (var) (variable-name (car var)))
  418.                (closure-env closure))) 
  419.   (create-environment (node-parent (node-parent (car vframe-lambdas))) 
  420.                       closure 0))
  421.  
  422.  
  423.  
  424. (define (create-environment node closure offset)
  425.   (let ((env (make-environment)))
  426.     (set (environment-closure    env) closure)
  427.     (set (environment-cic-offset env) offset)
  428.     (set (lambda-env node) env)))
  429.  
  430. (define (sort-vars vars)
  431.   (iterate loop ((vars vars) (pointer '()) (scratch '()))
  432.     (cond ((null? vars)
  433.            pointer)
  434.            ((eq? (variable-rep (car vars)) 'rep/pointer)
  435.             (loop (cdr vars) (cons (car vars) pointer) scratch))
  436.            (else
  437.             (loop (cdr vars) pointer (cons (car vars) scratch))))))
  438.  
  439. (define (bound-to-continuation? var)
  440.   (and (variable-binder var)
  441.        (any? (lambda (ref)
  442.                  (let ((exits (call-exits (node-parent ref))))
  443.                    (and (fx< exits 2)
  444.                         (fx= (call-arg-number (node-role ref)) exits))))
  445.                (variable-refs var))))
  446.  
  447.  
  448. (define (continuation? node)
  449.   (or (null? (lambda-variables node))
  450.       (cond ((car (lambda-variables node))
  451.              => (lambda (k) (not (bound-to-continuation? k))))
  452.             (else t))))
  453.  
  454.  
  455. (define scratch-compare identity)
  456.  
  457.  
  458.